let (&?) v m = v lor (lnot m) = -1
let (|?) v m = v land m <> 0

(* tables *)

type fine_control =
	[ `Bank | `Modulation | `Breath
	| `Foot | `PortamentoTime | `DataEntry | `Volume
	| `Balance | `Pan | `Expression
	| `Effect1 | `Effect2
	| `GP1 | `GP2 | `GP3 | `GP4
	| `Undefined of int ]
let fine_control_table: fine_control array =
	[| `Bank; `Modulation; `Breath; `Undefined 0x03;
	   `Foot; `PortamentoTime; `DataEntry; `Volume;
	   `Balance; `Undefined 0x09; `Pan; `Expression;
	   `Effect1; `Effect2; `Undefined 0x0E; `Undefined 0x0F;
	   `GP1; `GP2; `GP3; `GP4 |]

type coarse_control =
	[ `Sustain | `Portamento | `Sustenuto | `SoftPedal
	| `Legato | `Hold | `Sound1 | `Sound2
	| `Sound3 | `Sound4 | `Sound5 | `Sound6
	| `Sound7 | `Sound8 | `Sound9 | `Sound10
	| `GP5 | `GP6 | `GP7 | `GP8
	| `PortamentoControl (* depth? *)
	| `Effects1Depth
	| `Effects2Depth | `Effects3Depth | `Effects4Depth | `Effects5Depth
	| `DataIncrement | `DataDecrement | `NRPN_MSB | `NRPN_LSB
	| `RPN_MSB | `RPN_LSB
	| `Undefined of int ]
let coarse_control_table: coarse_control array =
	[| `Sustain; `Portamento; `Sustenuto; `SoftPedal;
	   `Legato; `Hold; `Sound1; `Sound2;
	   `Sound3; `Sound4; `Sound5; `Sound6;
	   `Sound7; `Sound8; `Sound9; `Sound10;
	   `GP5; `GP6; `GP7; `GP8;
	   `PortamentoControl; `Undefined 0x55; `Undefined 0x56; `Undefined 0x57;
	   `Undefined 0x58; `Undefined 0x59; `Undefined 0x5A; `Effects1Depth;
	   `Effects2Depth; `Effects3Depth; `Effects4Depth; `Effects5Depth;
	   `DataIncrement; `DataDecrement; `NRPN_MSB; `NRPN_LSB;
	   `RPN_MSB; `RPN_LSB |]
type control = [ fine_control | coarse_control | `LSB of fine_control ]

let control_of_int c =
	if c < 0x20 then
		(if c < Array.length fine_control_table then
			fine_control_table.(c)
		 else `Undefined c :> control)
	else if c < 0x40 then
		(`LSB (if c - 0x20 < Array.length fine_control_table then
		     	fine_control_table.(c - 0x20)
		      else `Undefined c) :> control)
	else
		(if c - 0x40 < Array.length coarse_control_table then
			coarse_control_table.(c)
		 else `Undefined c :> control)

type rpn =
	[ `PitchBendSensitivity | `FineTuning | `CoarseTuning | `TuningProgram
	| `TuningBank | `ModulationRange
	| `Undefined of int ]
let rpn_table: rpn array =
	[| `PitchBendSensitivity; `FineTuning; `CoarseTuning; `TuningProgram;
	   `TuningBank; `ModulationRange |]
let rpn_of_int r =
	if r < Array.length rpn_table then rpn_table.(r)
	else `Undefined r


(* messages *)

type note_message = [ `On | `Off | `Aftertouch ]
type key_id = int
type control_id = int
type voice_message =
	[ `Note of note_message * key_id * int
	| `Control of control_id * int
	| `Program of int
	| `Aftertouch of int
	| `PitchWheel of int ]
	
type mode_message =
	[ `AllSoundOff
	| `ResetAllControllers
	| `LocalControl of bool
	| `AllNotesOff
	| `Omni of bool
	| `Mono of int
	| `Poly ]

type channel_message = [ voice_message | mode_message ]

type mfg_id = int
type common_message =
	[ `SysEx of mfg_id * string
	| `SongPosition of int
	| `SongSelect of int
	| `TuneRequest
	| `Undefined_common of int ]

type realtime_message =
	[ `TimingClock | `Start | `Continue
	| `Stop | `ActiveSense | `Reset
	| `Undefined_realtime of int ]
let realtime_message_table: realtime_message array =
	[| `TimingClock; `Undefined_realtime 1; `Start; `Continue;
	   `Stop; `Undefined_realtime 5; `ActiveSense; `Reset |]

type system_message = [ common_message | realtime_message ]

type channel = int
type message =
	[ `Channel of channel * channel_message | `System of system_message ]


(* decoder *)

type 'a decoder = {
	mutable state: int -> 'a option;
	cc: (int -> 'a option) Stack.t;
}

let create_decoder (): message decoder =
	let d = {
		state = (fun _ -> assert false);
		cc = Stack.create ();
	} in
	
	
	(* helpers *)
	
	let expect f = d.state <- f; None
	and return v = d.state <- Stack.pop d.cc; Some v
	and return0 () = d.state <- Stack.pop d.cc; None
	(*and return_to v f = d.state <- f; Some v *)
	and push f = Stack.push f d.cc
	and save () = Stack.push d.state d.cc
	and reset () = Stack.clear d.cc
	and provide f b = assert (f = None); d.state b
	in

	
	(* states *)
	
	let rec byte f b =
		if b >= 0xF8 then (save (); realtime (b land 0b111))
		else if b >= 0x80 then (reset (); initial 0 b)
		else f b
	and expect_byte f = expect (byte f)
	and expect_pair f =
		expect_byte (fun a -> expect_byte (f a))
	and expect_word f =
		expect_pair (fun lsb msb -> f (msb lsl 7 lor lsb))
	
	and return_byte f = expect_byte (fun b -> return (f b))
	and return_pair f = expect_pair (fun a b -> return (f a b))
	and return_word f = expect_word (fun w -> return (f w))
	
	and sysex_main id l b =
		if b = 0b11110111 then
			(let b = Buffer.create 16 in
			 List.iter (Buffer.add_char b) (List.rev l);
			 return (`System (`SysEx (id, Buffer.contents b))))
		else byte (fun b ->
			expect (sysex_main id (char_of_int b :: l))) b
	
	and sysex () =
		expect_byte (fun b -> expect (sysex_main b []))
	
	and realtime b =
		return (`System (realtime_message_table.(b) :> system_message))
	
	and control ch =
		return_pair (fun c v ->
		`Channel (ch, match c with
			| 120 when v = 0 -> `AllSoundOff
			| 121 when v = 0 -> `ResetAllControllers
			| 122 when v = 0 -> `LocalControl false
			| 123 when v = 127 -> `LocalControl true
			| 123 when v = 0 -> `AllNotesOff
			| 124 when v = 0 -> `Omni false
			| 125 when v = 0 -> `Omni true
			| 126 -> `Mono v
			| 127 when v = 0 -> `Poly
			| c -> `Control (c, v)))
	
	and system_message = function
		| 0b000 -> sysex ()
		| 0b010 -> return_word (fun w -> `System (`SongPosition w))
		| 0b011 -> return_byte (fun b -> `System (`SongSelect b))
		| 0b110 -> return (`System `TuneRequest)
		| 0b111 -> return0 ()
		| m -> return (`System (`Undefined_common m))
	
	and channel_message ch = function
		| 0b000 -> return_pair (fun k v -> `Channel (ch, `Note (`Off, k, v)))
		| 0b001 -> return_pair (fun k v -> `Channel (ch, `Note (`On, k, v)))
		| 0b010 -> return_pair (fun k v -> `Channel (ch, `Note (`Aftertouch, k, v)))
		| 0b011 -> control ch
		| 0b100 -> return_byte (fun p -> `Channel (ch, `Program p))
		| 0b101 -> return_byte (fun p -> `Channel (ch, `Aftertouch p))
		| 0b110 -> return_word (fun w -> `Channel (ch, `PitchWheel (w - 0x2000)))
		| _ -> assert false

	and initial status b =
		if b < 0x80 then
			(* if b is data then try to use running status *)
			if status >= 0x80 then provide (initial status status) b
			(* if running status is invalid then simply ignore *)
			else expect (initial status)
		else
			let msb = b lsr 4 land 0x7
			and lsb = b land 0xF in
			if msb = 0b111 then
				if lsb >= 0b1000 then (push (initial status); realtime (lsb land 0b111))
				else (push (initial 0); system_message (lsb land 0b111))
			else (push (initial b); channel_message (lsb + 1) msb)
	in

	d.state <- initial 0;
	d

let decode d b = d.state b


(* encoder *)

(* TODO: running status *)

type encoder = unit

let create_encoder () = ()

let encode e (m: message) =
	let byte b = max 0 (min 0x7F b)
	and word w =
		let w = max 0 (min 0x3FFF w) in
		[ w land 0x7F; w lsr 7 ]
	in
	
	let rec sysex s =
		let d = ref [0b11110111] in
		String.iter (fun c -> d := int_of_char c :: !d) s;
		!d
	
	and realtime = function
		| `TimingClock -> 0b000
		| `Start -> 0b010
		| `Continue -> 0b011
		| `Stop -> 0b100
		| `ActiveSense -> 0b110
		| `Reset -> 0b111
		| `Undefined_realtime m -> m land 0b111
	
	and system_message = function
		| `SysEx (i, s) -> 0b0000, byte i :: sysex s
		| `SongPosition p -> 0b0010, word p
		| `SongSelect s -> 0b0011, [byte s]
		| `TuneRequest -> 0b0110, []
		| #realtime_message as m -> 0b1000 lor realtime m, []
		| `Undefined_common m -> m land 0b1111, []
	
	and mode_message = function
		| `AllSoundOff -> [120; 0]
		| `ResetAllControllers -> [121; 0]
		| `LocalControl b -> [122; if b then 127 else 0]
		| `AllNotesOff -> [123; 0]
		| `Omni b -> [if b then 125 else 124; 0]
		| `Mono n -> [126; byte n]
		| `Poly -> [127; 0]

	and channel_message = function
		| `Note (`Off, k, v) -> 0b000, [byte k; byte v]
		| `Note (`On, k, v) -> 0b001, [byte k; byte v]
		| `Note (`Aftertouch, k, v) -> 0b010, [byte k; byte v]
		| `Control (c, v) -> 0b011, [byte c; byte v]
		| `Program p -> 0b100, [byte p]
		| `Aftertouch v -> 0b101, [byte v]
		| `PitchWheel v -> 0b110, word (v + 0x2000)
		| #mode_message as m -> 0b011, mode_message m
	in
	
	match m with
	| `Channel (ch, m) ->
		let s, d = channel_message m in
		0x80 lor ((ch - 1) land 0xF) lor (s lsl 4) :: d
	| `System m ->
		let s, d = system_message m in
		0xF0 lor s :: d 
